The Josephus Problem — Complete Program

(* ocamlfind ocamlc   -o josephus -package extlib,kw -linkpkg josephus.ml *)
(* ocamlfind ocamlopt -o josephus -package extlib,kw -linkpkg josephus.ml *)

open Kw
open Printf

(* print usage message *)
let usage = sprintf "Usage: %s [-all | -graphic] [-delay FLOAT] N M"

let nm = ref []				(* [number of rebels; gap] *)
let all = ref false
let graphic = ref false
let delay = ref 0.1

let speclist = [
  ("-all", Arg.Unit (fun () -> all := true),
   (sprintf ": print all suicides; last is survivor (default: %s)"
      (string_of_bool !all)));
  ("-graphic", Arg.Unit (fun () -> graphic := true),
   (sprintf ": \"graphic\" display of process (default: %s)"
      (string_of_bool !graphic)));
  ("-delay", Arg.Float (fun f -> delay := f),
   (sprintf "FLOAT: delay (seconds) between suicides for -graphic (default: %f)"
      !delay));
]

(* return number of survivor *)
let josephus n m =
  let rec j circle =
    if Dllist.length circle = 1
    then Dllist.get circle
    else j (Dllist.drop (Dllist.skip circle (m-1)))
  in
    j (Dllist.of_list (1--n))

(* return number of survivor, size-tracking optimization *)
(* only twice as fast *)
let josephus n m =
  let rec j size circle =
    if size = 1
    then Dllist.get circle
    else j (size-1) (Dllist.drop (Dllist.skip circle (m-1)))
  in
  let dl = Dllist.of_list (1--n) in
    j (Dllist.length dl) dl

(* return number of survivor, size-tracking optimization, more efficient initialization *)
let josephus n m =
  let init n =
    let rec init' circle =
      let i = Dllist.get circle in
	if i = 1
	then circle
	else init' (Dllist.prepend circle (i-1))
    in
      init' (Dllist.create n)
  in
  let rec j size circle =
    if size = 1
    then Dllist.get circle
    else j (size-1) (Dllist.drop (Dllist.skip circle (m-1)))
  in
    j n (init n)

(* return list of suicides in order; last "suicide" is survivor *)
let josephus'all n m =
  let rec j circle acc =
    if Dllist.length circle = 1
    then (Dllist.get circle)::acc
    else let dead = Dllist.skip circle (m-1) in
      j (Dllist.drop dead) (Dllist.get dead::acc)
  in
    List.rev (j (Dllist.of_list (1--n)) [])

(* graphical version *)
let josephus'graphic n m =
  let width = int_of_float (ceil (log10 (float n))) in
  let print display = 
    Array.iter (fun s -> print_string s; print_char ' ') display;
    print_char '\r';
    flush stdout;
    ignore (Unix.select [] [] [] !delay)
  in
  let rec j circle display =
    if Dllist.length circle = 1
    then print_newline ()
    else
      let dead = Dllist.skip circle (m-1) in
      let i = Dllist.get dead in
	display.(i-1) <- String.make width 'x';
	print display;
	j (Dllist.drop dead) display
  in
  let display = Array.make n "" in
    for i = 0 to n-1 do
      display.(i) <- sprintf "%*d" width (i+1)
    done;
    print display;
    j (Dllist.of_list (1--n)) display

(* command-line arg parsing etc*)

exception Usage

let main () =
  let collect x = nm := !nm @ [x] in
  let msg = (usage (Filename.basename Sys.argv.(0))) in
  let _ = Arg.parse speclist collect msg in
    try
      match !nm with
	| [n;m] -> begin
	    let n, m = int_of_string n, int_of_string m in
	      match !all, !graphic with
		| true,true   -> raise Usage
		| true,false  -> List.iter (printf "%d\n") (josephus'all n m)
		| false,true  -> josephus'graphic n m
		| false,false -> printf "%d\n" (josephus n m)
	  end
	| _ -> raise Usage
    with Usage ->
      prerr_endline msg; exit 1

let () = main ()